Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/MyFMenus.p

Text File | 1997-04-18 | 9.9 KB | 434 lines | [TEXT/CWIE]

unit MyFMenus;

{ From Peter's PNL Libraries }
{ Copyright 1992 Peter N Lewis }
{ This source may be used for any non-commercial purposes as long as I get a mention }
{ in the About box and Docs of any derivative program.  It may not be used in any commercial }
{ application without my permission }

interface

    uses
        Types,
        Menus, Events, MyCallProc, MyAssertions;

    type
        FMenuMenuProc = procedure(themenu,theitem:integer);
        FMenuCommandProc = procedure;

    var
        thefmenu, thefitem: integer;
        menu_modifiers: integer;

    procedure StartupFMenus;
    procedure ConfigureFMenus (default: FMenuMenuProc);

    function GetFMenu (id: integer): MenuHandle;
{ Call this in place of GetMenu, to read in an fmnu resource.  Use InsertMenu to add it to the menu bar }
    procedure SetFCommand (command: OSType; cmdproc: FMenuCommandProc);
{ Call this to associate a procedure with a command OSType }
    procedure SetFSetMenu (command: OSType; smproc: FMenuMenuProc);
{ procedure smproc(themenu,theitem:integer) }
{ Call this to associate a procedure for enabling/disabling the menu item }
    procedure SetFBoth (command: OSType; cmdproc: FMenuCommandProc; smproc: FMenuMenuProc);
{ This is just a short form to set both the command and SetMenu procedures }

    function DoFMenuKey (const er: EventRecord): longint;
{ Calls SetFMenus and then MDEF_MenuKey }
    procedure SetFMenus;
{ Call this before MenuKey or MenuSelect to set the enables of all the menus }
    procedure SetFMenu (themenu: integer);
{ Call this to set the enables of all the items in themenu }
    procedure DoFMenu (themenu, theitem: integer);
{ Call this to act on a menu selection from either MenuSelect or MenuKey }

{ You probably won't need these }
    procedure AddFCommand (themenu, theitem: integer; command: OSType);
{ Call this to associate a menu item with an OSType - normally done by GetFMenu }
    procedure GetCommand (themenu, theitem: integer; var command: OSType);
{ Call this to figure out what command OSType is associated with a menu item - normally done via DoFMenu }
    procedure DoCommand (themenu, theitem: integer; command: OSType);
{ Call this to execute a menu command - normally done via DoFMenu }

implementation

    uses
        Resources, Script, Memory, OSUtils,
        BaseGlobals,MyCallProc, MyMemory, MyStartup, MyEvents, MyMathUtils;

    const
        min_menu_time = 6;

{$PUSH}
{$ALIGN MAC68K}

    type
        fmenuHeader = record
                visible: integer;
                count: integer;
                unknown1: integer;
                menuID: integer;
                unknown2: integer;
                unknown3: integer;
                name: Str63;
            end;
        fmenuHeaderPtr = ^fmenuHeader;
        fmenuItem = packed record
                command: OSType;
                mark: char;
                unknown2: Byte;
                cmdKey: char;
                disabled: Byte;
                name: Str63;
            end;
        fmenuItemPtr = ^fmenuItem;

{$ALIGN RESET}
{$POP}

    type
        convertRecord = record
                menu, item: integer;
                cmd: OSType;
                cmdp: FMenuCommandProc;
                smp: FMenuMenuProc;
            end;
        convertArray = array[1..1000] of convertRecord;
        convertPtr = ^convertArray;
        convertHandle = ^convertPtr;

{$ifc do_debug}
    var
        startup_check: integer;
{$endc}

    var
        convert_count: integer;
        converts: convertHandle;
        DefaultMenuProc: FMenuMenuProc;

    procedure AddFCommand (themenu, theitem: integer; command: OSType);
    begin
        if BAND(convert_count, 7) = 0 then begin
            SetHandleSize(Handle(converts), (convert_count + 8) * SizeOf(convertRecord));
        end;
        convert_count := convert_count + 1;
        with converts^^[convert_count] do begin
            menu := themenu;
            item := theitem;
            cmd := command;
            cmdp := nil;
            smp := nil;
        end;
    end;

    procedure NextPtr (var p: univ Ptr; sp: univ Ptr);
    begin
        p := Ptr(longint(sp) + sp^ + 2 - ord(odd(sp^)));
    end;

    function GetFMenu (id: integer): MenuHandle;
        var
            h: Handle;
            mh: MenuHandle;
            ph: fmenuHeaderPtr;
            p: fmenuItemPtr;
            s: Str255;
            i: integer;
    begin
        AssertDidStartup( startup_check );
        h := GetResource('fmnu', id);
        HLock(h);
        ph := fmenuHeaderPtr(h^);
        mh := NewMenu(ph^.menuID, ph^.name);

        NextPtr(p, @ph^.name);
        for i := 1 to ph^.count do begin
            if p^.name = '-' then begin
                AppendMenu(mh, '(-');
            end else begin
                AddFCommand(ph^.menuID, i, p^.command);
                s := p^.name;
                if p^.mark <> chr(0) then begin
                    s := concat(s, '!', p^.mark);
                end;
                if p^.cmdKey <> chr(0) then begin
                    s := concat(s, '/', p^.cmdKey);
                end;
                if p^.disabled = 1 then begin
                    s := concat('(', s);
                end;
                AppendMenu(mh, s);
            end;
            NextPtr(p, @p^.name);
        end;
        ReleaseResource(h);

        GetFMenu := mh;
    end;

    procedure FindMenu (themenu, theitem: integer; var i: integer);
    begin
        i := 1;
        while i <= convert_count do begin
            with converts^^[i] do begin
                if (menu = themenu) and (item = theitem) then begin
                    Exit(FindMenu);
                end;
            end;
            i := i + 1;
        end;
        i := -1;
    end;

    procedure SetFCommand (command: OSType; cmdproc: FMenuCommandProc);
        var
            i: integer;
{$ifc do_debug}
            found_one: boolean;
{$endc}
    begin
        AssertDidStartup( startup_check );
        Assert( converts <> nil );
{$ifc do_debug}
        found_one := false;
{$endc}
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if cmd = command then begin
                    cmdp := cmdproc;
{$ifc do_debug}
                    found_one := true;
{$endc}
                end;
            end;
        end;
{$ifc do_debug}
        Assert( found_one );
{$endc}
    end;

    procedure SetFSetMenu (command: OSType; smproc: FMenuMenuProc);
        var
            i: integer;
{$ifc do_debug}
            found_one: boolean;
{$endc}
    begin
        AssertDidStartup( startup_check );
        Assert( converts <> nil );
{$ifc do_debug}
        found_one := false;
{$endc}
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if cmd = command then begin
                    smp := smproc;
{$ifc do_debug}
                    found_one := true;
{$endc}
                end;
            end;
        end;
{$ifc do_debug}
        Assert( found_one );
{$endc}
    end;

    procedure SetFBoth (command: OSType; cmdproc: FMenuCommandProc; smproc: FMenuMenuProc);
        var
            i: integer;
{$ifc do_debug}
            found_one: boolean;
{$endc}
    begin
        AssertDidStartup( startup_check );
        Assert( converts <> nil );
{$ifc do_debug}
        found_one := false;
{$endc}
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if cmd = command then begin
                    cmdp := cmdproc;
                    smp := smproc;
{$ifc do_debug}
                    found_one := true;
{$endc}
                end;
            end;
        end;
{$ifc do_debug}
        Assert( found_one );
{$endc}
    end;

    procedure GetCommand (themenu, theitem: integer; var command: OSType);
        var
            i: integer;
    begin
        FindMenu(themenu, theitem, i);
        if i = -1 then begin
            command := 'xxx0';
        end else begin
            command := converts^^[i].cmd;
        end;
    end;

    procedure DoCmd (themenu, theitem: integer; cmdp: FMenuCommandProc);
    begin
        thefmenu := themenu;
        thefitem := theitem;
        if cmdp = nil then begin
            DefaultMenuProc(themenu, theitem);
        end else begin
            cmdp;
        end;
    end;

    procedure DoCommand (themenu, theitem: integer; command: OSType);
        var
            cmdproc: FMenuCommandProc;
            i: integer;
    begin
        cmdproc := nil;
        i := 1;
        while i <= convert_count do begin
            with converts^^[i] do begin
                if cmd = command then begin
                    cmdproc := cmdp;
                    leave;
                end;
            end;
            i := i + 1;
        end;
        DoCmd(themenu, theitem, cmdproc);
    end;

    procedure DoFMenu (themenu, theitem: integer);
        var
            i: integer;
            t: longint;
            tmp_hack: FMenuCommandProc;
    begin
        t := TickCount;
        FindMenu(themenu, theitem, i);
        if i = -1 then begin
            DoCmd(themenu, theitem, nil);
        end else begin
            tmp_hack := converts^^[i].cmdp;
            DoCmd(themenu, theitem, tmp_hack);
        end;
        if not quitNow then begin
            t := TickCount - t;
            if t < min_menu_time then begin
                Delay(min_menu_time - t, t);
            end;
            HiliteMenu(0);
        end;
    end;

    procedure SetFMenus;
        var
            i: integer;
            dummy: boolean;
            er: EventRecord;
    begin
        dummy := OSEventAvail(everyEvent, er);
        menu_modifiers := er.modifiers;
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if smp <> nil then begin
                    smp(menu, item);
                end;
            end;
        end;
    end;

    function DoFMenuKey (const er: EventRecord): longint;
        const
            kMaskVirtualKey = $0000FF00; {get virtual key from event message}
            kMaskASCII1 = $00FF0000;
            kMaskASCII2 = $000000FF; {get key from KeyTrans return}
            kKeyUpMask = $0080;
        var
            h: Handle;
            keyCId, keyInfo: longint;
            state: UInt32;
            keycode: UInt16;
            lowchar, highchar: integer;
            ch: Char;
    begin
        ch := EventChar( er );
        if EventHasOptionKey( er ) or EventHasControlKey( er ) then begin
            keycode := BAND(SInt32(Ord4(er.modifiers)), GoodBNOT(optionKey + controlKey)); { lose option&control }
            keycode := BOR(BOR(SInt16(Ord(keycode)), kKeyUpMask), EventKeyCode( er ));
            state := 0;

            keyCId := GetScriptVariable(GetScriptManagerVariable(smKeyScript), smScriptKeys);
            h := GetResource('KCHR', keyCId);

            if h <> nil then begin
                HLock(h); { KeyTrans won't move memory, but lock it anyway to avoid any purging or foolishness }
                keyInfo := KeyTranslate(h^, keycode, state);
                ReleaseResource(h);
                lowchar := BAND(keyInfo, $00FF);
                highchar := BAND(BSR(keyInfo, 16), $00FF);
                if lowchar <> 0 then begin
                    ch := chr(lowchar);
                end;
                if highchar <> 0 then begin
                    ch := chr(highchar);
                end;
            end;
        end;
        DoFMenuKey := MenuKey(ch);
    end;

    procedure SetFMenu (themenu: integer);
        var
            i: integer;
            dummy: boolean;
            er: EventRecord;
    begin
        dummy := OSEventAvail(everyEvent, er);
        menu_modifiers := er.modifiers;
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if (themenu = menu) & (smp <> nil) then begin
                    smp(menu, item);
                end;
            end;
        end;
    end;

    function InitFMenus (var msg: integer): OSStatus;
    begin
{$unused(msg)}
        AssertDidStartup( startup_check );
        convert_count := 0;
        InitFMenus := MNewHandle(converts, 0);
    end;

    procedure FinishFMenus;
    begin
        MDisposeHandle( converts );
    end;

    procedure ConfigureFMenus (default: FMenuMenuProc);
    begin
        DidStartup( startup_check );
        StartupFMenus;
        if default = nil then begin
            default := DoFMenu;
        end;
        DefaultMenuProc := default;
    end;

    procedure StartupFMenus;
    begin
        SetStartup(InitFMenus, nil, 0, FinishFMenus);
    end;

end.